home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / interp / def.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  8.0 KB  |  280 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: def.c,v 1.14 94/10/20 03:05:36 wlott Exp $
  27. *
  28. * This file implements the stuff to install definitions.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include "../compat/std-c.h"
  33.  
  34. #include "mindy.h"
  35. #include "module.h"
  36. #include "sym.h"
  37. #include "thread.h"
  38. #include "func.h"
  39. #include "list.h"
  40. #include "bool.h"
  41. #include "obj.h"
  42. #include "def.h"
  43. #include "type.h"
  44. #include "instance.h"
  45. #include "error.h"
  46. #include "class.h"
  47.  
  48. static void maybe_copy_methods(obj_t new_gf, obj_t old_gf)
  49. {
  50.     obj_t methods;
  51.  
  52.     if (old_gf == obj_Unbound)
  53.     return;
  54.     check_type(new_gf, obj_GFClass);
  55.     check_type(old_gf, obj_GFClass);
  56.  
  57.     methods = generic_function_methods(old_gf);
  58.  
  59.     while (methods != obj_Nil) {
  60.     add_method(new_gf, HEAD(methods));
  61.     methods = TAIL(methods);
  62.     }
  63. }
  64.  
  65.  
  66. /* Stuff to define builtin stuff. */
  67.  
  68. void define(char *name, obj_t value)
  69. {
  70.     obj_t namesym = symbol(name);
  71.     struct variable *var;
  72.  
  73.     define_variable(module_BuiltinStuff, namesym, var_Variable);
  74.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  75.     maybe_copy_methods(value, var->value);
  76.     var->value = value;
  77.     var->function = func_Maybe;
  78. }
  79.  
  80. void define_constant(char *name, obj_t value)
  81. {
  82.     obj_t namesym = symbol(name);
  83.     struct variable *var;
  84.  
  85.     define_variable(module_BuiltinStuff, namesym, var_Constant);
  86.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  87.     maybe_copy_methods(value, var->value);
  88.     var->value = value;
  89.     var->function = func_Maybe;
  90. }
  91.  
  92. void define_function(char *name, obj_t specializers, boolean restp,
  93.              obj_t keywords, boolean all_keys, obj_t result_type,
  94.              obj_t (*func)())
  95. {
  96.     define_constant(name,
  97.             make_builtin_method(name, specializers, restp, keywords,
  98.                     all_keys, result_type, func));
  99. }
  100.  
  101. void define_generic_function(char *name, int req_args, boolean restp,
  102.                  obj_t keys, boolean all_keys, obj_t result_types,
  103.                  obj_t more_results_type)
  104. {
  105.     obj_t namesym = symbol(name);
  106.     struct variable *var;
  107.     obj_t gf = make_generic_function(namesym, req_args, restp, keys, all_keys,
  108.                      result_types, more_results_type);
  109.  
  110.     define_variable(module_BuiltinStuff, namesym, var_GenericFunction);
  111.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  112.     maybe_copy_methods(gf, var->value);
  113.     var->value = gf;
  114.     var->function = func_Always;
  115. }
  116.  
  117. void define_method(char *name, obj_t specializers, boolean restp,
  118.            obj_t keywords, boolean all_keys, obj_t result_type,
  119.            obj_t (*func)())
  120. {
  121.     obj_t namesym = symbol(name);
  122.     obj_t method = make_builtin_method(name, specializers, restp,
  123.                        keywords, all_keys, result_type, func);
  124.     struct variable *var;
  125.     obj_t gf;
  126.  
  127.     define_variable(module_BuiltinStuff, namesym, var_Method);
  128.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  129.     gf = var->value;
  130.     if (gf == obj_Unbound) {
  131.     gf = make_default_generic_function(namesym, method);
  132.     var->value = gf;
  133.     var->function = func_Always;
  134.     }
  135.     else
  136.     check_type(gf, obj_GFClass);
  137.     add_method(gf, method);
  138. }
  139.  
  140. void define_class(char *name, obj_t value)
  141. {
  142.     obj_t namesym = symbol(name);
  143.     struct variable *var;
  144.  
  145.     define_variable(module_BuiltinStuff, namesym, var_Class);
  146.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  147.     maybe_copy_methods(value, var->value);
  148.     var->value = value;
  149.     var->function = func_No;
  150. }
  151.  
  152.  
  153. /* Stuff to define/initialize defined stuff. */
  154.  
  155. static obj_t init_variable(obj_t var_obj, obj_t value, obj_t type)
  156. {
  157.     struct variable *var = obj_rawptr(var_obj);
  158.  
  159.     maybe_copy_methods(value, var->value);
  160.     var->value = value;
  161.     var->type = type;
  162.     if (type != obj_False && subtypep(type, obj_FunctionClass))
  163.     var->function = func_Always;
  164.     else if (instancep(value, obj_FunctionClass))
  165.     var->function = func_Yes;
  166.     else
  167.     var->function = func_No;
  168.  
  169.     return var->name;
  170. }
  171.  
  172. static obj_t defmethod(obj_t var_obj, obj_t method)
  173. {
  174.     struct variable *var = obj_rawptr(var_obj);
  175.     obj_t gf = var->value;
  176.     obj_t old;
  177.  
  178.     if (gf == obj_Unbound) {
  179.     gf = make_default_generic_function(var->name, method);
  180.     var->value = gf;
  181.     var->function = func_Always;
  182.     }
  183.     else
  184.     check_type(gf, obj_GFClass);
  185.     old = add_method(gf, method);
  186.  
  187.     if (old != obj_False)
  188.     error("Definition of %= clashes with %=", method, old);
  189.  
  190.     return var->name;
  191. }
  192.  
  193. static obj_t defgeneric(obj_t var_obj, obj_t signature, obj_t restp,
  194.             obj_t keywords, obj_t all_keys, obj_t result_types,
  195.             obj_t more_results_type)
  196. {
  197.     struct variable *var = obj_rawptr(var_obj);
  198.     obj_t gf = var->value;
  199.  
  200.     if (more_results_type == obj_True)
  201.     more_results_type = obj_ObjectClass;
  202.  
  203.     if (gf == obj_Unbound) {
  204.     var->value = make_generic_function(var->name, length(signature),
  205.                        restp != obj_False, keywords,
  206.                        all_keys != obj_False, result_types,
  207.                        more_results_type);
  208.     var->function = func_Always;
  209.     }
  210.     else
  211.     set_gf_signature(gf, length(signature), restp != obj_False, keywords,
  212.              all_keys != obj_False, result_types,
  213.              more_results_type);
  214.  
  215.     return var->name;
  216. }
  217.  
  218. static obj_t defclass1(obj_t class, obj_t superclasses)
  219. {
  220.     setup_class_supers(class, superclasses);
  221.  
  222.     return class;
  223. }
  224.  
  225. static obj_t defclass2(obj_t class, obj_t slots,
  226.                obj_t initargs, obj_t inheriteds)
  227. {
  228.     init_defined_class(class, slots, initargs, inheriteds);
  229.  
  230.     /* init_defined_class doesn't return */
  231.     lose("init_defined_class actually returned?\n");
  232.     return NULL;
  233. }
  234.  
  235. static obj_t defslot(obj_t getter, obj_t setter)
  236. {
  237.     struct variable *var;
  238.  
  239.     if (setter != obj_False) {
  240.     var = obj_rawptr(setter);
  241.     if (var->value == obj_Unbound)
  242.         var->value = make_generic_function(var->name, 2, FALSE, obj_False,
  243.                            FALSE, obj_Nil,
  244.                            obj_ObjectClass);
  245.     }
  246.  
  247.     var = obj_rawptr(getter);
  248.     if (var->value == obj_Unbound)
  249.     var->value = make_generic_function(var->name, 1, FALSE, obj_False,
  250.                        FALSE, obj_Nil, obj_ObjectClass);
  251.  
  252.     return var->name;
  253. }
  254.  
  255.  
  256. /* Init stuff. */
  257.  
  258. void init_def_functions(void)
  259. {
  260.     define_function("init-variable",
  261.             list3(obj_ObjectClass, obj_ObjectClass, obj_ObjectClass),
  262.             FALSE, obj_False, FALSE, obj_ObjectClass, init_variable);
  263.     define_function("%define-method", list2(obj_ObjectClass, obj_ObjectClass),
  264.             FALSE, obj_False, FALSE, obj_ObjectClass, defmethod);
  265.     define_function("%define-generic",
  266.             listn(7, obj_ObjectClass, obj_ObjectClass, obj_ObjectClass,
  267.               obj_ObjectClass, obj_ObjectClass, obj_ObjectClass,
  268.               obj_ObjectClass),
  269.             FALSE, obj_Nil, FALSE, obj_ObjectClass, defgeneric);
  270.     define_function("%define-class-1",
  271.             list2(obj_ObjectClass, obj_ObjectClass),
  272.             FALSE, obj_False, FALSE, obj_ObjectClass, defclass1);
  273.     define_function("%define-class-2",
  274.             listn(4, obj_ObjectClass, obj_ObjectClass,
  275.               obj_ObjectClass, obj_ObjectClass),
  276.             FALSE, obj_False, FALSE, obj_ObjectClass, defclass2);
  277.     define_function("%define-slot", list2(obj_ObjectClass, obj_ObjectClass),
  278.             FALSE, obj_False, FALSE, obj_ObjectClass, defslot);
  279. }
  280.